Deutsche Edition 1/Deutsche Edition 1.iso/amok/amok_lha/amok02.lha/IntuiStruct/IntuiStruct.mod

Modula Implementation | 1993-08-16 | 8.7 KB | 378 lines

(**********************************************************************

    :Program.       IntuiStruct.mod
    :Author.        Nicolas Benezan
    :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
    :Phone.      [phone]
    :shortcut.      [bne]
    :Version.       1.0a
    :Date.          23.05.88
    :Copyright.  Public Domain (siehe ReadMe)
    :Language.      Modula-II
    :Translator. M2Amiga AMSoft
    :Update
    :Contents.     Easy initializing of Intuition structures
    :Remark.     Copy and use it but please leave my name in, thanks.

**********************************************************************)

IMPLEMENTATION MODULE IntuiStruct;

FROM Intuition    IMPORT NewScreen,ScreenFlagSet,NewWindow,IDCMPFlagSet,
        WindowFlagSet,ScreenPtr,stdScreenHeight,Image,ImagePtr,
                IntuiText,IntuiTextPtr,Gadget,GadgetPtr,GadgetFlagSet,
                GadgetFlags,ActivationFlagSet,PropInfo,PropInfoFlagSet,
                StringInfo,Menu,MenuPtr,MenuItem,MenuItemPtr,
                MenuItemFlagSet,MenuItemFlags,menuEnabled,WindowPtr,
                RefreshGadgets,RequesterPtr;
FROM Graphics    IMPORT ViewModeSet,ViewModes,DrawModeSet,jam1;
FROM GfxMacros    IMPORT RasSize;
FROM SYSTEM    IMPORT ADR,ADDRESS,BITSET,LONGSET,WORD,CAST;
FROM Exec    IMPORT Byte,UByte;
FROM Arts    IMPORT Assert;
FROM Heap    IMPORT Allocate,AllocMem,Deallocate;

CONST    CHIP=TRUE;
    CorruptImage="Image Struct corrupt";

TYPE    WordPtr=POINTER TO CARDINAL;
VAR    CurImagePtr:WordPtr;
    Size,Count:INTEGER;
        SubItemPtr,ItemPtr:MenuItemPtr;
        MenuOK:BOOLEAN;

PROCEDURE StructScreen(VAR NewSc:NewScreen;Depth,Detail,Block:Byte;
    Mode:ViewModeSet;Type:ScreenFlagSet;Title:ADDRESS);
BEGIN
  WITH NewSc DO
    leftEdge:=0;
    topEdge:=0;
    IF hires IN Mode THEN
      width:=640;
    ELSE
      width:=320;
    END;
    height:=stdScreenHeight;
    depth:=Depth;
    detailPen:=CAST(UByte,Detail);
    blockPen:=CAST(UByte,Block);
    viewModes:=Mode;
    type:=Type;
    font:=NIL;
    defaultTitle:=Title;
    gadgets:=NIL;
    customBitMap:=NIL;
  END;
END StructScreen;

PROCEDURE StructWindow(VAR NewW:NewWindow;Left,Top,Width,Height:INTEGER;
    Detail,Block:Byte;IDCMP:IDCMPFlagSet;Flags:WindowFlagSet;
        Title:ADDRESS;Screen:ScreenPtr;Type:ScreenFlagSet);
BEGIN
  WITH NewW DO
    leftEdge:=Left;
    topEdge:=Top;
    width:=Width;
    height:=Height;
    detailPen:=CAST(UByte,Detail);
    blockPen:=CAST(UByte,Block);
    idcmpFlags:=IDCMP;
    flags:=Flags;
    firstGadget:=NIL;
    checkMark:=NIL;
    title:=Title;
    screen:=Screen;
    bitMap:=NIL;
    type:=Type;
    minWidth:=0;
    minHeight:=0;
    maxWidth:=0;
    maxHeight:=0;
  END;
END StructWindow;

PROCEDURE StructImage(VAR NewImage:Image;Left,Top,Width,Height,Depth:
    INTEGER;Pick,OnOff:BITSET;Next:ImagePtr);
BEGIN
  Assert(Size=0,ADR(CorruptImage));
  WITH NewImage DO
    leftEdge:=Left;
    topEdge:=Top;
    width:=Width;
    height:=Height;
    depth:=Depth;
    IF Depth#0 THEN
      Size:=2*depth*height*((width-1)DIV 16 +1);
      AllocMem(imageData,Size,CHIP);
    END;
    planePick:=CAST(CARDINAL,Pick);
    planeOnOff:=CAST(CARDINAL,OnOff);
    nextImage:=Next;
  END;
  Count:=0;
  CurImagePtr:=NewImage.imageData;
END StructImage;

PROCEDURE Word(Data:CARDINAL);
BEGIN
  Assert((CurImagePtr#NIL)AND(Count<Size-1),ADR(CorruptImage));
  CurImagePtr^:=Data;
  INC(CurImagePtr,2);
  INC(Count,2);
END Word;

PROCEDURE Long(Data:LONGCARD);
BEGIN
  Word(Data DIV 10000H);
  Word(Data MOD 10000H);
END Long;

PROCEDURE ImageEnd;
BEGIN
  Assert(Count=Size,ADR(CorruptImage));
  Size:=0;
  Count:=-1;
  CurImagePtr:=NIL;
END ImageEnd;

PROCEDURE StructText(VAR IText:IntuiText;APen,BPen:Byte;Mode:DrawModeSet;
    Left,Top:INTEGER;Text:ADDRESS;Next:IntuiTextPtr);
BEGIN
  WITH IText DO
    frontPen:=CAST(UByte,APen);
    backPen:=CAST(UByte,BPen);
    drawMode:=Mode;
    leftEdge:=Left;
    topEdge:=Top;
    iTextFont:=NIL;
    iText:=Text;
    nextText:=Next;
  END;
END StructText;

PROCEDURE StructGadget(VAR NewGadg:Gadget;Left,Top,Width,Height:INTEGER;
    Flags:GadgetFlagSet;Activ:ActivationFlagSet;Type:CARDINAL;
        Render:ADDRESS;Text:IntuiTextPtr;Excl:LONGSET;ID:INTEGER;
        Next:GadgetPtr);
BEGIN
  WITH NewGadg DO
    nextGadget:=Next;
    leftEdge:=Left;
    topEdge:=Top;
    width:=Width;
    height:=Height;
    flags:=Flags;
    activation:=Activ;
    gadgetType:=Type;
    gadgetRender:=Render;
    selectRender:=NIL;
    gadgetText:=Text;
    mutualExclude:=Excl;
    specialInfo:=NIL;
    gadgetID:=ID;
    userData:=NIL;
  END;
END StructGadget;

PROCEDURE ExcludeGadget(Gadgets:GadgetPtr;Window:WindowPtr;
        Requester:RequesterPtr;Mask:LONGSET);
VAR    TempPtr:GadgetPtr;
    Bit:INTEGER;
BEGIN
  Bit:=0;
  WHILE (Gadgets#NIL)AND(Bit<32) DO
    IF (Bit IN Mask)AND(selected IN Gadgets^.flags) THEN
      WITH Gadgets^ DO
        flags:=flags-GadgetFlagSet{selected};
        TempPtr:=nextGadget;
        nextGadget:=NIL;
        RefreshGadgets(Gadgets,Window,Requester);
        nextGadget:=TempPtr;
      END;
    END;
    Gadgets:=Gadgets^.nextGadget;
    INC(Bit);
  END;
END ExcludeGadget;

PROCEDURE StructProp(VAR Info:PropInfo;Flags:PropInfoFlagSet;
    HPot,VPot,HBody,VBody:CARDINAL);
BEGIN
  WITH Info DO
    flags:=Flags;
    horizPot:=HPot;
    vertPot:=VPot;
    horizBody:=HBody;
    vertBody:=VBody;
  END;
END StructProp;

PROCEDURE StructString(VAR Info:StringInfo;VAR Buffer,UndoBuf:
    ARRAY OF CHAR);
BEGIN
  WITH Info DO
    buffer:=ADR(Buffer);
    undoBuffer:=ADR(UndoBuf);
    bufferPos:=0;
    maxChars:=HIGH(Buffer);
    dispPos:=0;
  END;
  Assert(HIGH(UndoBuf)>=Info.maxChars,
    ADR("StringGadget: UndoBuf too small"));
END StructString;

PROCEDURE LinkItems(ItemPtr:MenuItemPtr);
VAR    TopEdge:INTEGER;
BEGIN
  TopEdge:=0;
  WHILE ItemPtr#NIL DO
    WITH ItemPtr^ DO
      topEdge:=TopEdge;
      IF subItem#NIL THEN
        LinkItems(subItem);
      END;
    END;
    INC(TopEdge,StdHeight);
    ItemPtr:=ItemPtr^.nextItem;
  END;
END LinkItems;

PROCEDURE LinkMenu(VAR MenuStrip:MenuPtr;Name:ADDRESS;Pos,Width:
    INTEGER;Enabled:BOOLEAN):BOOLEAN;
VAR    TempPtr:MenuPtr;
BEGIN
  IF MenuOK THEN
    Assert(SubItemPtr=NIL,ADR("Menu Struct corrupt"));
    Allocate(TempPtr,SIZE(Menu));
    IF TempPtr#NIL THEN
      TempPtr^.nextMenu:=MenuStrip;
      MenuStrip:=TempPtr;
      WITH MenuStrip^ DO
        leftEdge:=Pos;
        topEdge:=0;
        width:=Width;
        height:=StdHeight;
        IF Enabled THEN
          flags:={menuEnabled};
        ELSE
          flags:={};
        END;
        menuName:=Name;
        firstItem:=ItemPtr;
        LinkItems(ItemPtr);
      END;
      ItemPtr:=NIL;
      RETURN TRUE;
    END;
  END;
  ItemPtr:=NIL;
  MenuOK:=TRUE;
  RETURN FALSE;
END LinkMenu;

PROCEDURE InitItem(VAR ItemPtr:MenuItemPtr):BOOLEAN;
VAR    TempPtr:MenuItemPtr;
BEGIN
  Allocate(TempPtr,SIZE(MenuItem));
  IF TempPtr#NIL THEN
    Allocate(TempPtr^.itemFill,SIZE(IntuiText));
    IF TempPtr^.itemFill#NIL THEN
      TempPtr^.nextItem:=ItemPtr;
      ItemPtr:=TempPtr;
      RETURN TRUE;
    ELSE
      Deallocate(TempPtr);
    END;
  END;
  MenuOK:=FALSE;
  RETURN FALSE;
END InitItem;

PROCEDURE InitText(VAR TextPtr:IntuiTextPtr;Text:ADDRESS;Flags:
    MenuItemFlagSet);
BEGIN
  WITH TextPtr^ DO
    frontPen:=0;
    drawMode:=jam1;
    IF checkIt IN Flags THEN
      leftEdge:=CheckWidth;
    ELSE
      leftEdge:=0;
    END;
    topEdge:=1;
    iTextFont:=NIL;
    iText:=Text;
  END;
END InitText;

PROCEDURE Item(Name:ADDRESS;Width:INTEGER;Flags:MenuItemFlagSet;
    Excl:LONGSET;Cmd:CHAR);
BEGIN
  IF InitItem(ItemPtr) THEN
    WITH ItemPtr^ DO
      leftEdge:=0;
      width:=Width;
      IF checkIt IN Flags THEN
        INC(width,CheckWidth);
      END;
      height:=StdHeight;
      flags:=Flags;
      mutualExclude:=Excl;
      command:=Cmd;
      subItem:=SubItemPtr;
      InitText(CAST(IntuiTextPtr,itemFill),Name,Flags);
    END;
  END;
  SubItemPtr:=NIL;
END Item;

PROCEDURE SubItem(Name:ADDRESS;LeftEdge,Width:INTEGER;Flags:
    MenuItemFlagSet;Excl:LONGSET;Cmd:CHAR);
BEGIN
  IF InitItem(SubItemPtr) THEN
    WITH SubItemPtr^ DO
      leftEdge:=LeftEdge;
      width:=Width;
      height:=StdHeight;
      flags:=Flags;
      mutualExclude:=Excl;
      command:=Cmd;
      subItem:=NIL;
      InitText(CAST(IntuiTextPtr,itemFill),Name,Flags);
    END;
  END;
END SubItem;

PROCEDURE MenuNum(Num:CARDINAL):CARDINAL;
BEGIN
  RETURN Num MOD 0020H;
END MenuNum;

PROCEDURE ItemNum(Num:CARDINAL):CARDINAL;
BEGIN
  RETURN Num DIV 0020H MOD 0040H;
END ItemNum;

PROCEDURE SubNum(Num:CARDINAL):CARDINAL;
BEGIN
  RETURN Num DIV 0800H;
END SubNum;

PROCEDURE MakeNum(Menu,Item,SubItem:CARDINAL):CARDINAL;
BEGIN
  RETURN (Menu MOD 20H)+(Item MOD 40H)*0020H+(SubItem MOD 20H)*800H;
END MakeNum;

BEGIN
  CurImagePtr:=NIL;
  ItemPtr:=NIL;
  SubItemPtr:=NIL;
  Size:=0;
  Count:=-1;
  CommWidth:=48;
  CheckWidth:=24;
  StdHeight:=10;
  MenuOK:=TRUE;

END IntuiStruct.